home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / 0292.ZIP / WAMPUM.ARC / MENU.PRG < prev    next >
Text File  |  1985-12-21  |  7KB  |  384 lines
  1. * MENU.PRG (Version 1.0) is the Main Procedure File
  2. PROCEDURE MAIN
  3. STORE "1.0" TO VERSION
  4. STORE " " TO OPTION
  5. DO WHILE Option <> '0'
  6. STORE ' ' TO Option
  7. CLEAR
  8. CLOSE FORMAT
  9. STORE "<Esc>" TO Pick
  10. @  1,2 SAY DATE()
  11. @  1,70 SAY TIME()
  12. @  3,15 SAY HEADING
  13. @  6 ,0 SAY "                   Please select one of ";
  14. + "the following options:                  "
  15. @  9 ,0  SAY "            1  ADD NEW ENTRY TO SYSTEM  ";
  16. + "    6  PRINT "+USERRPT1
  17. @  11 ,0 SAY "            2  MODIFY EXISTING ENTRY    ";
  18. + "    7  PRINT "+USERRPT2
  19. @  13 ,0 SAY "            3  DELETE EXISTING ENTRY    ";
  20. + "    8  PRINT "+USERRPT3
  21. @  15 ,0 SAY "            4  RESTORE EXISTING ENTRY   ";
  22. + "    9  SUPPLEMENTAL REPORTS             "
  23. @  17 ,0 SAY "            5  SUPPLEMENTAL LABELS      ";
  24. + "    0  EXIT TO dBASE III           "
  25. @  20 ,0 SAY "                             My choice i";
  26. + "s                                       "
  27. @  20 , 44  GET OPTION PICTURE "N"
  28. READ
  29. DO CASE
  30.    CASE UPPER(OPTION)='D'
  31.      DO DELUSER
  32.    CASE UPPER(OPTION)='R'
  33.      DO RESTUSER
  34.    CASE UPPER(OPTION)='U'
  35.      DO RESTUSER
  36.    CASE UPPER(OPTION)='C'
  37.      DO CHANGEM
  38.    CASE OPTION='1'
  39.      DO ADDUSER
  40.    CASE OPTION='2'
  41.      DO MODUSER
  42.    CASE OPTION='3'
  43.      DO DELUSER
  44.    CASE OPTION='4'
  45.      DO RESTUSER
  46.    CASE OPTION='5'
  47.      DO SUPPLABL
  48.    CASE OPTION='6'
  49.      DO USERRPT1
  50.    CASE OPTION='7'
  51.      DO USERRPT2
  52.    CASE OPTION='8'
  53.      DO USERRPT3
  54.    CASE OPTION='9'
  55.      DO SUPPRPT
  56. ENDCASE
  57. ENDDO
  58. RETURN
  59.  
  60. PROCEDURE DELUSER
  61. CLEAR GETS
  62. STORE ' ' TO Option
  63. @  22 ,0 SAY "        Are you sure you want DELETE mod";
  64. + "e                                       "
  65. @  22 , 44  GET OPTION PICTURE "!"
  66. READ
  67. IF Option <> 'Y'
  68.   RETURN
  69. ENDIF
  70. STORE ' ' TO ThisRec
  71. STORE ' ' TO Wrath
  72. DO WHILE LEN(ThisRec)>0
  73.   CLOSE FORMAT
  74.   CLEAR
  75.   STORE '               ' TO ThisRec
  76.   @ 10,15 SAY Wrath
  77.   @ 12,15 SAY "Enter Key ID of record to DELETE: " GET ThisRec
  78.   READ
  79.   STORE ' ' TO Wrath
  80.   STORE TRIM(ThisRec) TO ThisRec
  81.   IF LEN(ThisRec)=0
  82.     LOOP
  83.   ENDIF
  84.   SEEK ThisRec
  85.   IF EOF() .OR. BOF()
  86.     GO TOP
  87.     STORE "Record Not Found." TO Wrath
  88.     ? CHR(7)
  89.     LOOP
  90.   ENDIF
  91.   SET FORMAT TO DISP
  92.   EDIT
  93.   STORE "<Esc>" TO Pick
  94.   IF EOF() .OR. BOF()
  95.     GO TOP
  96.     STORE "End of File Reached." TO Wrath
  97.     ? CHR(7)
  98.     LOOP
  99.   ENDIF
  100. STORE RECNO() TO ThisRec
  101.   DELETE
  102.   CLEAR
  103.   ? "RECORD HAS BEEN DELETED."
  104.   GO TOP
  105. ENDDO
  106. ? "   "
  107. WAIT
  108. RETURN
  109.  
  110. PROCEDURE RESTUSER
  111. CLEAR GETS
  112. STORE ' ' TO Option
  113. @  22 ,0 SAY "       Are you sure you want RESTORE mod";
  114. + "e                                       "
  115. @  22 , 44  GET OPTION PICTURE "!"
  116. READ
  117. IF Option <> 'Y'
  118.   RETURN
  119. ENDIF
  120. STORE ' ' TO ThisRec
  121. STORE ' ' TO Wrath
  122. DO WHILE LEN(ThisRec)>0
  123.   CLOSE FORMAT
  124.   CLEAR
  125.   STORE '               ' TO ThisRec
  126.   @ 10,15 SAY Wrath
  127.   @ 12,15 SAY "Enter Item Key of Record to RESTORE: " GET ThisRec
  128.   READ
  129.   STORE ' ' TO Wrath
  130.   STORE TRIM(ThisRec) TO ThisRec
  131.   IF LEN(ThisRec)=0
  132.     LOOP
  133.   ENDIF
  134.   SEEK ThisRec
  135.   IF EOF() .OR. BOF()
  136.     GO TOP
  137.     STORE "Record Not Found." TO Wrath
  138.     ? CHR(7)
  139.     LOOP
  140.   ENDIF
  141.   SET FORMAT TO DISP
  142.   EDIT
  143.   STORE "<Esc>" TO Pick
  144.   IF EOF() .OR. BOF()
  145.     GO TOP
  146.     STORE "End of File Reached." TO Wrath
  147.     ? CHR(7)
  148.     LOOP
  149.   ENDIF
  150. STORE RECNO() TO ThisRec
  151.   RECALL
  152.   CLEAR
  153.   ? "RECORD RESTORED AS REQUESTED."
  154.   GO TOP
  155. ENDDO
  156. ? "   "
  157. WAIT
  158. RETURN
  159.  
  160. PROCEDURE ADDUSER
  161. CLEAR
  162. IF MENU<>SPACE(8)
  163.   SET FORMAT TO &MENU
  164. ENDIF
  165. APPEND
  166. CLOSE FORMAT
  167. GO TOP
  168. CLEAR
  169. RETURN
  170.  
  171. PROCEDURE MODUSER
  172. STORE ' ' TO ThisRec
  173. STORE ' ' TO Wrath
  174. DO WHILE LEN(ThisRec)>0
  175.   CLOSE FORMAT
  176.   CLEAR
  177.   CLEAR GETS
  178.   THISREC=SPACE(30)
  179.   @ 10,10 SAY Wrath
  180.   @ 12,10 SAY "Enter Item Key of Record to Find: " GET ThisRec
  181.   READ
  182.   STORE ' ' TO Wrath
  183.   STORE TRIM(ThisRec) TO ThisRec
  184.   IF LEN(ThisRec)=0
  185.     LOOP
  186.   ENDIF
  187.   SEEK ThisRec
  188.   IF EOF()
  189.     GO TOP
  190.     STORE "Record is not on File." TO Wrath
  191.     ? CHR(7)
  192.     LOOP
  193.   ENDIF
  194.   IF MENU<>SPACE(8)
  195.     SET FORMAT TO &MENU
  196.   ENDIF
  197.   EDIT
  198. ENDDO
  199. CLOSE FORMAT
  200. CLEAR
  201. RETURN
  202.  
  203. PROCEDURE PRINTSUB
  204. STORE ' ' TO PFlag
  205. CLEAR
  206. @ 12,15 SAY "Make sure PRINTER is ON. Then press P to print: " GET PFlag PICTURE '!'
  207. READ
  208. IF PFlag <> 'P'
  209.   STORE ' ' TO PFlag
  210.   RETURN
  211. ELSE
  212. * SET PRINT ON
  213. * ? CHR(27)+"!"+CHR(22)
  214. * SET PRINT OFF
  215.   CLEAR
  216.   @ 12,20 SAY "Processing Report. Please wait. . . ."
  217. RETURN
  218.  
  219. PROCEDURE SELECT
  220. IF TYPE('THISPICK')='U'
  221.   THISPICK=SPACE(40)
  222. ENDIF
  223. IF LEN(THISPICK)<40
  224.   THISPICK=THISPICK+SPACE(40-LEN(THISPICK))
  225. ENDIF
  226. CLEAR GETS
  227. @ 24,7 SAY "Enter selection criteria " GET THISPICK
  228. READ
  229. THISPICK=TRIM(THISPICK)
  230. IF LEN(THISPICK)>0
  231.   CRITERIA="FOR "+THISPICK
  232. ELSE
  233.   CRITERIA=" "
  234. ENDIF
  235. RETURN
  236.  
  237. PROCEDURE USERRPT1
  238. DO SELECT
  239. DO PRINTSUB
  240. SET DELETED ON
  241. CLEAR
  242. IF PFLAG = ' '
  243.   LABEL FORM &REPORT1 &CRITERIA
  244.   WAIT
  245. ELSE
  246.   LABEL FORM &REPORT1 &CRITERIA TO PRINT
  247.   EJECT
  248. ENDIF
  249. GO TOP
  250. SET DELETED OFF
  251. RETURN
  252.  
  253. PROCEDURE USERRPT2
  254. DO SELECT
  255. DO PRINTSUB
  256. SET DELETED ON
  257. SELECT 1
  258. CLEAR
  259. IF PFLAG = ' '
  260.   REPORT FORM &REPORT2 &CRITERIA
  261.   WAIT
  262. ELSE
  263.   REPORT FORM &REPORT2 &CRITERIA NOEJECT TO PRINT
  264.   EJECT
  265. ENDIF
  266. GO TOP
  267. SET DELETED OFF
  268. RETURN
  269.  
  270. PROCEDURE USERRPT3
  271. DO SELECT
  272. DO PRINTSUB
  273. SET DELETED ON
  274. SELECT 1
  275. CLEAR
  276. IF PFLAG = ' '
  277.   REPORT FORM &REPORT3 &CRITERIA
  278.   WAIT
  279. ELSE
  280.   REPORT FORM &REPORT3 &CRITERIA NOEJECT TO PRINT
  281.   EJECT
  282. ENDIF
  283. GO TOP
  284. SET DELETED OFF
  285. RETURN
  286.  
  287. PROCEDURE SUPPRPT
  288. CLEAR
  289. @ 1,0 SAY "The following report formats are on file:"
  290. ? " "
  291. DIR *.FRM
  292. RPT=SPACE(8)
  293. @ 22,7 SAY "Enter report name or <RETURN> for dBASE ASSIST:         .FRM"
  294. @ 22,55 GET RPT PICTURE '!!!!!!!!'
  295. READ
  296. IF RPT<>SPACE(8)
  297.   RPT=TRIM(RPT)+".FRM"
  298. ENDIF
  299. DO CASE
  300.  CASE RPT=SPACE(8)
  301.    CLEAR
  302.    SET TALK ON
  303.    ASSIST
  304.    SET TALK OFF
  305.    &FILESPEC
  306. *CASE FILE(RPT)
  307.  OTHERWISE  -->> Use this for AT's only since it can't check directory.
  308.    DO SELECT
  309.    DO PRINTSUB
  310.    SET DELETED ON
  311.    CLEAR
  312.    IF PFLAG = ' '
  313.      REPORT FORM &RPT &CRITERIA
  314.      WAIT
  315.    ELSE
  316.      REPORT FORM &RPT &CRITERIA NOEJECT TO PRINT
  317.      EJECT
  318.    ENDIF
  319.    SET DELETED OFF
  320.    GO TOP
  321. ENDCASE
  322. RETURN
  323.  
  324. PROCEDURE SUPPLABL
  325. CLEAR
  326. @ 1,0 SAY "The following label routines are on file:"
  327. ? " "
  328. DIR *.LBL
  329. RPT=SPACE(8)
  330. @ 22,7 SAY "Enter label name or <RETURN> for dBASE ASSIST:         .LBL"
  331. @ 22,54 GET RPT PICTURE '!!!!!!!!'
  332. READ
  333. IF RPT<>SPACE(8)
  334.   RPT=TRIM(RPT)+".LBL"
  335. ENDIF
  336. DO CASE
  337.  CASE RPT=SPACE(8)
  338.    CLEAR
  339.    SET TALK ON
  340.    ASSIST
  341.    SET TALK OFF
  342.    &FILESPEC
  343. *CASE FILE(RPT)
  344.  OTHERWISE  -->> Use this for AT's only since it can't check directory.
  345.    DO SELECT
  346.    DO PRINTSUB
  347.    SET DELETED ON
  348.    CLEAR
  349.    IF PFLAG = ' '
  350.      LABEL FORM &RPT &CRITERIA
  351.      WAIT
  352.    ELSE
  353.      LABEL FORM &RPT &CRITERIA NOEJECT TO PRINT
  354.      EJECT
  355.    ENDIF
  356.    SET DELETED OFF
  357.    GO TOP
  358. ENDCASE
  359. RETURN
  360.  
  361. PROCEDURE CHANGEM
  362. CLEAR
  363. SET FORMAT TO CONFIG
  364. READ
  365. UFLAG=.T.
  366. CLEAR
  367. CLOSE FORMAT
  368. @ 12,20 SAY "Update Configuration File? " GET UFLAG
  369. READ
  370. CLEAR
  371. IF UFLAG
  372.   SAVE TO CONFIG
  373.   ? CHR(7)
  374.   @ 14,20 SAY "Configuration File Updated."
  375. ENDIF
  376. RETURN
  377.  " GET UFLAG
  378. READ
  379. CLEAR
  380. IF UFLAG
  381.   SAVE TO CONFIG
  382.   ? CHR(7)
  383.   @ 14,20 SAY "Configuration File Updated."
  384. E